home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / thomas / thomas.lha / Thomas / Thomas-1.1 / src / runtime-collections-deque.scm < prev    next >
Text File  |  1992-08-30  |  13KB  |  362 lines
  1. ;*              Copyright 1992 Digital Equipment Corporation
  2. ;*                         All Rights Reserved
  3. ;*
  4. ;* Permission to use, copy, and modify this software and its documentation is
  5. ;* hereby granted only under the following terms and conditions.  Both the
  6. ;* above copyright notice and this permission notice must appear in all copies
  7. ;* of the software, derivative works or modified versions, and any portions
  8. ;* thereof, and both notices must appear in supporting documentation.
  9. ;* 
  10. ;* Users of this software agree to the terms and conditions set forth herein,
  11. ;* and hereby grant back to Digital a non-exclusive, unrestricted, royalty-free
  12. ;* right and license under any changes, enhancements or extensions made to the
  13. ;* core functions of the software, including but not limited to those affording
  14. ;* compatibility with other hardware or software environments, but excluding
  15. ;* applications which incorporate this software.  Users further agree to use
  16. ;* their best efforts to return to Digital any such changes, enhancements or
  17. ;* extensions that they make and inform Digital of noteworthy uses of this
  18. ;* software.  Correspondence should be provided to Digital at:
  19. ;* 
  20. ;*            Director, Cambridge Research Lab
  21. ;*            Digital Equipment Corp
  22. ;*            One Kendall Square, Bldg 700
  23. ;*            Cambridge MA 02139
  24. ;* 
  25. ;* This software may be distributed (but not offered for sale or transferred
  26. ;* for compensation) to third parties, provided such third parties agree to
  27. ;* abide by the terms and conditions of this notice.
  28. ;* 
  29. ;* THE SOFTWARE IS PROVIDED "AS IS" AND DIGITAL EQUIPMENT CORP. DISCLAIMS ALL
  30. ;* WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING ALL IMPLIED WARRANTIES OF
  31. ;* MERCHANTABILITY AND FITNESS.   IN NO EVENT SHALL DIGITAL EQUIPMENT
  32. ;* CORPORATION BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL
  33. ;* DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR
  34. ;* PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS
  35. ;* ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS
  36. ;* SOFTWARE.
  37.  
  38. ; $Id: runtime-collections-deque.scm,v 1.13 1992/08/31 04:31:56 birkholz Exp $
  39.  
  40. ;;;; Specializations for Deque Type
  41.  
  42. (add-method dylan:as
  43.   (dylan::function->method
  44.    (make-param-list `((CLASS ,(dylan::make-singleton <deque>))
  45.               (OBJECT ,<collection>)) #F #F #F)
  46.    (lambda (class object)
  47.      (if (not (subclass? (dylan-call dylan:object-class object) <collection>))
  48.      (dylan-call dylan:error
  49.              "as -- cannot convert a non-collection to a collection"
  50.              class object (dylan-call dylan:object-class object)))
  51.      (let* ((new-deque (dylan-call dylan:make <deque>)))
  52.        (do ((state (dylan-call dylan:initial-state object)
  53.            (dylan-call dylan:next-state object state))
  54.         (index 0 (+ index 1)))
  55.        ((not state) new-deque)
  56.      (dylan-call dylan:push-last
  57.              new-deque
  58.              (dylan-call dylan:current-element object state)))))))
  59.  
  60. ;;;
  61. ;;; DEQUE SPECIALIZED MAKE
  62. ;;; Two slots: front and end of deque
  63. ;;;
  64.  
  65. (define dylan:get-deque-front "define dylan:get-deque-front")
  66. (define dylan:get-deque-last "define dylan:get-deque-last")
  67. (define dylan:set-deque-front! "define dylan:set-deque-front!")
  68. (define dylan:set-deque-last! "define dylan:set-deque-last!")
  69. (create-private-slot <deque> <object> "internal-deque-front"
  70.   (lambda (set get)
  71.     (set! dylan:set-deque-front! set)
  72.     (set! dylan:get-deque-front get)))
  73. (create-private-slot <deque> <object> "internal-deque-last"
  74.   (lambda (set get)
  75.     (set! dylan:set-deque-last! set)
  76.     (set! dylan:get-deque-last get)))
  77.  
  78. (add-method
  79.  dylan:make
  80.  (dylan::dylan-callable->method
  81.   (make-param-list `((DEQUE ,(dylan::make-singleton <deque>)))
  82.            #F #F '(size: fill:))
  83.   (lambda (multiple-values next-method class . rest)
  84.     multiple-values class        ; Not used
  85.     (dylan::keyword-validate next-method rest '(size: fill:))
  86.     (let* ((size (dylan::find-keyword rest 'size: (lambda () 0)))
  87.        (fill (dylan::find-keyword rest 'fill: (lambda () #F))))
  88.       (if (or (not (integer? size)) (negative? size))
  89.       (dylan-call dylan:error
  90.               "make -- deque size invalid" size))
  91.       (let ((instance (dylan::make-<object> <deque>)))
  92.     (dylan-call dylan:set-deque-front! instance '())
  93.     (dylan-call dylan:set-deque-last! instance '())
  94.     (do ((n 0 (+ n 1)))
  95.         ((= n size) instance)
  96.       (dylan-call dylan:push instance fill)))))))
  97.  
  98. ;;;;
  99. ;;;; Functions for Sequences (page 104)
  100. ;;;;
  101.  
  102. (add-method dylan:add
  103.   (dylan::function->method one-deque-and-an-object
  104.     (lambda (deque new-element)
  105.       (dylan-call dylan:push deque new-element))))
  106.  
  107.  
  108. (define dylan::push
  109.   (lambda (deque new-value)
  110.     (let* ((old-deque-front (dylan-call dylan:get-deque-front deque))
  111.        (new-entry (make-deque-entry #F old-deque-front new-value)))
  112.       (if old-deque-front
  113.       (set-deque-entry.previous! old-deque-front new-entry)
  114.       (dylan-call dylan:set-deque-last! deque new-entry))
  115.       (dylan-call dylan:set-deque-front! deque new-entry)
  116.       deque)))
  117.  
  118. (add-method dylan:add!
  119.   (dylan::function->method one-deque-and-a-value dylan::push))
  120.  
  121.  
  122. (add-method
  123.  dylan:remove!
  124.  (dylan::dylan-callable->method
  125.   (make-param-list `((DEQUE ,<deque>) (VALUE ,<object>)) #F #F '(test: count:))
  126.   (lambda (multiple-values next-method deque value . rest)
  127.     multiple-values
  128.     (dylan::keyword-validate next-method rest '(test: count:))
  129.     (let ((test? (dylan::find-keyword rest 'test: (lambda () dylan:id?)))
  130.       (count (dylan::find-keyword
  131.           rest 'count: (lambda () (dylan-call dylan:size deque))))
  132.       (num-changed 0)
  133.       (front-entry (dylan-call dylan:get-deque-front deque)))
  134.       (cond ((null? front-entry) front-entry)
  135.         ((null? (deque-entry.next front-entry))
  136.          (if (and (> count 0) (dylan-call test?
  137.                           (deque-entry.value front-entry)
  138.                           value))
  139.          (begin
  140.            (dylan-call dylan:set-deque-front! deque #F)
  141.            (dylan-call dylan:set-deque-last! deque #F)))
  142.          deque)
  143.         (else
  144.          (let loop ((front-entry front-entry))
  145.            (if (and (> count num-changed)
  146.             (dylan-call test?
  147.                     (deque-entry.value front-entry)
  148.                     value))
  149.            (let ((next-entry (deque-entry.next front-entry)))
  150.              (set! num-changed (+ num-changed 1))
  151.              (set-deque-entry.previous! next-entry #F)
  152.              (dylan-call dylan:set-deque-front! deque next-entry)
  153.              (if next-entry
  154.              (loop next-entry)
  155.              deque))))
  156.          (let loop ((current-entry
  157.              (deque-entry.next
  158.               (dylan-call dylan:get-deque-front deque)))
  159.             (num-changed num-changed))
  160.            (if (or (null? current-entry) (>= num-changed count))
  161.            deque
  162.            (if (dylan-call test?
  163.                    (deque-entry.value current-entry)
  164.                    value)
  165.                (let ((prev (deque-entry.previous current-entry))
  166.                  (next (deque-entry.next current-entry)))
  167.              (if prev
  168.                  (set-deque-entry.next! prev next)
  169.                  (dylan-call dylan:set-deque-front! deque next))
  170.              (if next
  171.                  (begin
  172.                    (set-deque-entry.previous! next prev)
  173.                    (loop next (+ num-changed 1)))
  174.                  (begin
  175.                    (dylan-call dylan:set-deque-last! deque prev)
  176.                    deque)))
  177.                (loop (deque-entry.next current-entry)
  178.                  num-changed))))))))))
  179.  
  180.  
  181. (add-method
  182.  dylan:remove-duplicates!
  183.  (dylan::dylan-callable->method
  184.   (make-param-list `((DEQUE ,<deque>)) #F #F '(test:))
  185.   (lambda (multiple-values next-method old-deque . rest)
  186.     multiple-values
  187.     (dylan::keyword-validate next-method rest '(test:))
  188.     (let* ((test? (dylan::find-keyword rest 'test: (lambda () dylan:id?)))
  189.        (new-deque
  190.         (dylan-call dylan:remove-duplicates old-deque 'test: test?)))
  191.       (do ((count (dylan-call dylan:size old-deque) (- count 1)))
  192.       ((<= count 0) 'done)
  193.     (dylan-call dylan:pop old-deque))
  194.       (do ((count (dylan-call dylan:size new-deque) (- count 1)))
  195.       ((<= count 0) old-deque)
  196.     (dylan-call dylan:push-last
  197.             old-deque (dylan-call dylan:pop new-deque)))))))
  198.  
  199.  
  200. (add-method dylan:concatenate
  201.   (dylan::function->method
  202.     (make-param-list `((DEQUE ,<deque>)) #F #T #F)
  203.     (lambda (deque-1 . rest)
  204.       (let loop ((result-deque (dylan-call dylan:make <deque>))
  205.          (all-collections (cons deque-1 rest)))
  206.     (for-each (lambda (collection)
  207.             (iterate! (lambda (element)
  208.                 (dylan-call dylan:push-last
  209.                         result-deque element))
  210.                   collection))
  211.           all-collections)
  212.     result-deque))))
  213.  
  214. (add-method dylan:reverse
  215.   (dylan::function->method one-deque
  216.     (lambda (deque-1)
  217.       (let ((result (dylan-call dylan:make <deque>)))
  218.     (do ((state (dylan-call dylan:initial-state deque-1)
  219.             (dylan-call dylan:next-state deque-1 state)))
  220.         ((not state) result)
  221.       (dylan-call dylan:push
  222.               result
  223.               (dylan-call dylan:current-element deque-1 state)))))))
  224.  
  225. (add-method dylan:reverse!
  226.   (dylan::function->method one-deque
  227.     (lambda (deque-1)
  228.       (let ((tmp-deque (dylan-call dylan:make <deque>))
  229.         (size (dylan-call dylan:size deque-1)))
  230.     (if (<= size 0)
  231.         deque-1
  232.         (begin
  233.           (do ((i 1 (+ i 1)))
  234.           ((= i size) 'continue)
  235.         (dylan-call dylan:push
  236.                 tmp-deque (dylan-call dylan:pop deque-1)))
  237.           (do ((i 1 (+ i 1)))
  238.           ((= i size) deque-1)
  239.         (dylan-call dylan:push-last
  240.                 deque-1 (dylan-call dylan:pop tmp-deque)))))))))
  241.  
  242. (add-method
  243.  dylan:sort!
  244.  (dylan::dylan-callable->method
  245.   (make-param-list `((DEQUE ,<deque>)) #F #F '(test: stable:))
  246.   (lambda (multiple-values next-method deque . rest)
  247.     multiple-values
  248.     (dylan::keyword-validate next-method rest '(test: stable:))
  249.     (let* ((test? (dylan::find-keyword rest 'test: (lambda () dylan:<)))
  250.        (stable (dylan::find-keyword rest 'stable: (lambda () #F)))
  251.        (deque-list (sort (iterate->list (lambda (x) x) deque)
  252.                  (lambda (x y)
  253.                    (dylan-call test? x y)))))
  254.       stable                ; Ignored
  255.       (dylan::empty-deque! deque)
  256.       (for-each (lambda (x) (dylan-call dylan:push-last deque x))
  257.         deque-list)
  258.       deque))))
  259.  
  260.  
  261.  
  262. ;;;;
  263. ;;;; OPERATIONS ON DEQUES (page 114)
  264. ;;;;
  265.  
  266. (define deque-entry-type
  267.   (make-record-type
  268.    'deque-entry
  269.    '(previous                ; Pointer to previous entry
  270.      next                ; Pointer to next entry
  271.      value                ; Value of this entry
  272.      )))
  273. (define deque-entry? (record-predicate deque-entry-type))
  274. (define make-deque-entry (record-constructor deque-entry-type))
  275. (define deque-entry.previous (record-accessor deque-entry-type 'previous))
  276. (define deque-entry.next (record-accessor deque-entry-type 'next))
  277. (define deque-entry.value (record-accessor deque-entry-type 'value))
  278. (define set-deque-entry.previous! (record-updater deque-entry-type 'previous))
  279. (define set-deque-entry.next! (record-updater deque-entry-type 'next))
  280. (define set-deque-entry.value! (record-updater deque-entry-type 'value))
  281.  
  282. (define (dylan::empty-deque! deque)
  283.   (let ((size (dylan-call dylan:size deque)))
  284.     (do ((i 0 (+ i 1)))
  285.     ((= i size) deque)
  286.       (dylan-call dylan:pop deque))))
  287.  
  288. (define dylan:push
  289.   (dylan::generic-fn 'push one-deque-and-a-value dylan::push))
  290.  
  291. (define dylan:pop
  292.   (dylan::generic-fn 'pop
  293.     one-deque
  294.     (lambda (deque)
  295.       (let ((old-front-entry (dylan-call dylan:get-deque-front deque)))
  296.     (if old-front-entry
  297.         (let ((old-front-value (deque-entry.value old-front-entry))
  298.           (second-entry (deque-entry.next old-front-entry)))
  299.           (if second-entry
  300.           (begin
  301.             (dylan-call dylan:set-deque-front! deque second-entry)
  302.             (set-deque-entry.previous! second-entry #F))
  303.           (begin
  304.             (dylan-call dylan:set-deque-front! deque #F)
  305.             (dylan-call dylan:set-deque-last! deque #F)))
  306.           old-front-value)
  307.         (dylan-call dylan:error "pop -- deque is empty" deque))))))
  308.  
  309. (define dylan:push-last
  310.   (dylan::generic-fn 'push-last
  311.     one-deque-and-a-value
  312.     (lambda (deque new-value)
  313.       (let* ((old-deque-last (dylan-call dylan:get-deque-last deque))
  314.          (new-entry (make-deque-entry old-deque-last #F new-value)))
  315.     (if old-deque-last
  316.         (set-deque-entry.next! old-deque-last new-entry)
  317.         (dylan-call dylan:set-deque-front! deque new-entry))
  318.     (dylan-call dylan:set-deque-last! deque new-entry)
  319.     deque))))
  320.  
  321. (define dylan:pop-last
  322.   (dylan::generic-fn 'pop-last
  323.     one-deque
  324.     (lambda (deque)
  325.       (let ((old-last-entry (dylan-call dylan:get-deque-last deque)))
  326.     (if old-last-entry
  327.         (let ((old-last-value (deque-entry.value old-last-entry))
  328.           (previous-entry (deque-entry.previous old-last-entry)))
  329.           (if previous-entry
  330.           (begin
  331.             (dylan-call dylan:set-deque-last! deque previous-entry)
  332.             (set-deque-entry.next! previous-entry #F))
  333.           (begin
  334.             (dylan-call dylan:set-deque-last! deque #F)
  335.             (dylan-call dylan:set-deque-front! deque #F)))
  336.           old-last-value)
  337.         (dylan-call dylan:error
  338.             "pop-last -- deque is empty" deque))))))
  339.  
  340. ;  (add-method dylan:initialize
  341. ;    (dylan::generic-fn
  342. ;     'initialize
  343. ;     (make-param-list `((DEQUE ,<deque>)) #T #F #F)
  344. ;     (lambda (next obj)
  345. ;       '...))))
  346.  
  347.  
  348. ;;;
  349. ;;; Mutable Collection
  350. ;;;
  351.  
  352.  
  353. (add-method dylan:setter/current-element/
  354.   (dylan::function->method
  355.     (make-param-list
  356.      `((DEQUE ,<deque>) (STATE ,<object>) (new-value ,<object>))
  357.      #F #F #F)
  358.     (lambda (deque state new-value)
  359.       deque
  360.       (set-deque-entry.value! state new-value)
  361.       new-value)))
  362.